VB:Tutorials:BNK and RLE
__TOC__ Saving BMP files to a custom resource file, may lead to a very large file. That's because all the pixels in a BMP are saved, but why should we? Why not use a simple compression like RLE. This algorithm will replace a long line of the same characters. And because the background of a tile or picture has mostly all the same bytes (in 256) we can use this well. Let's say you have a file: BMPINFO COLOURTABLE BLABLA BMPDATA: AAAAAAAAAABAAAAAAAAAA A simple one line bmp file of 21 pixels, now when you would use RLE it would become for example: BMPINFO COLOURTABLE BLABLA BMPDATA: A*10BA*10 WOW! your file is now 20 bytes smaller, of course I know that isn't much, but this is also a small file. I've added this compression method to Ryan's BNK resource program. And the average ratio is 20%! That saves much space. BUT, there's one disadvantage, the compression is REALLY slow on large files, so we can't use tilesets. Now the source: I've added a extra ExtractData sub, because we are going to extract normal .bmp files, and our own resource file, including an extra long. Why? We need to save the size of the BMPData after the compression, we cannot calculate it anymore, doh! The ExtractData for RLE Sub ExtractData_RLE(strFileName As String, lngOffset As Long) Dim intBMPFile As Integer Dim lngBMPData As Long Dim i As Integer 'Init variables Erase gudtBMPInfo.bmiColors 'Open the bitmap intBMPFile = FreeFile() Open strFileName For Binary Access Read Lock Write As intBMPFile 'Fill the File Header structure Get intBMPFile, lngOffset, gudtBMPFileHeader 'Fill the Info structure Get intBMPFile, , gudtBMPInfo.bmiHeader If gudtBMPInfo.bmiHeader.biClrUsed <> 0 Then For i = 0 To gudtBMPInfo.bmiHeader.biClrUsed - 1 Get intBMPFile, , gudtBMPInfo.bmiColors(i).rgbBlue Get intBMPFile, , gudtBMPInfo.bmiColors(i).rgbGreen Get intBMPFile, , gudtBMPInfo.bmiColors(i).rgbRed Get intBMPFile, , gudtBMPInfo.bmiColors(i).rgbReserved Next i Else Get intBMPFile, , gudtBMPInfo.bmiColors End If 'How long is our compressed BMPData array? Get intBMPFile, , lngBMPData 'Size the BMPData array ReDim gudtBMPData(lngBMPData) 'ReDim gudtBMPData(FileSize(gudtBMPInfo.bmiHeader.biWidth, gudtBMPInfo.bmiHeader.biHeight)) 'Fill the BMPData array Get intBMPFile, , gudtBMPData 'Ensure info is correct gudtBMPFileHeader.bfOffBits = 1078 gudtBMPInfo.bmiHeader.biSizeImage = FileSize(gudtBMPInfo.bmiHeader.biWidth, gudtBMPInfo.bmiHeader.biHeight) gudtBMPInfo.bmiHeader.biClrUsed = 0 gudtBMPInfo.bmiHeader.biClrImportant = 0 gudtBMPInfo.bmiHeader.biXPelsPerMeter = 0 gudtBMPInfo.bmiHeader.biYPelsPerMeter = 0 Close intBMPFile Call RLE.DeCompress_RLE(gudtBMPData) End Sub As you can see I didn't change much The RLE Module: Option Explicit Public Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, source As Any, ByVal Length As Long) Public OriginalSize As Long 'size of the original file Public NewSize As Long 'size after decryption Public WorkArray() As Byte 'array to store the results 'Compress file Public Sub Compress_RLE(ByteArray() As Byte) OriginalSize = UBound(ByteArray) + 1 Dim OutStream() As Byte Dim FileLong As Long Dim X As Long Dim Char As Byte Dim OldChar As Integer Dim RLE_Count As Integer Dim OutPos As Long FileLong = UBound(ByteArray) ReDim OutStream(FileLong) 'worst case OutPos = 0 OldChar = -1 RLE_Count = 0 For X = 0 To FileLong Char = ByteArray(X) If Char = OldChar Then RLE_Count = RLE_Count + 1 If RLE_Count < 4 Then Call AddCharToArray(OutStream, OutPos, Char) End If If RLE_Count = 256 Then Call AddCharToArray(OutStream, OutPos, CByte(RLE_Count - 3)) RLE_Count = 0 OldChar = -1 End If Else If RLE_Count > 2 Then Call AddCharToArray(OutStream, OutPos, CByte(RLE_Count - 3)) End If Call AddCharToArray(OutStream, OutPos, Char) RLE_Count = 1 OldChar = Char End If Next If RLE_Count > 2 Then Call AddCharToArray(OutStream, OutPos, CByte(RLE_Count - 3)) End If OutPos = OutPos - 1 ReDim ByteArray(OutPos) NewSize = OutPos + 1 Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1) End Sub 'DeCompress file Public Sub DeCompress_RLE(ByteArray() As Byte) NewSize = UBound(ByteArray) + 1 Dim OutStream() As Byte Dim FileLong As Long Dim X As Long Dim Y As Integer Dim RRun1 As Boolean Dim RRun2 As Boolean Dim Char As Byte Dim OldChar As Integer Dim RLE_Count As Byte Dim OutPos As Long OutPos = 0 ReDim OutStream(UBound(ByteArray)) RRun1 = False RRun2 = False OldChar = -1 For X = 0 To UBound(ByteArray) If RRun1 = True Then If RRun2 = True Then RLE_Count = ByteArray(X) For Y = 1 To RLE_Count Call AddCharToArray(OutStream, OutPos, Char) Next RRun1 = False RRun2 = False OldChar = -1 Else Char = ByteArray(X) Call AddCharToArray(OutStream, OutPos, Char) If Char = OldChar Then RRun2 = True Else RRun1 = False End If OldChar = Char End If Else Char = ByteArray(X) Call AddCharToArray(OutStream, OutPos, Char) If Char = OldChar Then RRun1 = True OldChar = Char End If Next OutPos = OutPos - 1 ReDim ByteArray(OutPos) OriginalSize = OutPos + 1 Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1) End Sub 'this sub will add a char into the outputstream Private Sub AddCharToArray(ToArray() As Byte, ToPos As Long, Char As Byte) If ToPos > UBound(ToArray) Then ReDim Preserve ToArray(ToPos + 500) End If ToArray(ToPos) = Char ToPos = ToPos + 1 End Sub The new mnuFileAdd_Click sub Private Sub mnuFileAdd_Click() Dim lngTemp As Long Dim strPath As String Dim strFileList As String Dim strFiles() As String Dim i As Integer 'If there is no "current" file, then make a new one first If gstrFileName = "" Then MsgBox "Open/create a BNK file first!" Exit Sub End If 'Add a bitmap to the bank file cmdDialog.FileName = "" cmdDialog.Flags = HideReadOnly Or FileMustExist Or AllowMultiSelect Or LongNames Or Explorer cmdDialog.Filter = "Bitmap Files (*.bmp)|*.bmp" cmdDialog.DialogTitle = "Select one/more BMP file(s)" On Error Resume Next cmdDialog.ShowOpen 'If the user canceled out of the dialog, exit sub If Err.Number = cdlCancel Or cmdDialog.FileName = "" Then Exit Sub End If On Error GoTo 0 'Handle multiple selection ReDim strFiles(0) strPath = "" If InStr(1, cmdDialog.FileName, Chr(0)) > 0 Then strPath = Left(cmdDialog.FileName, InStr(1, cmdDialog.FileName, Chr(0)) - 1) & "\" cmdDialog.FileName = Right(cmdDialog.FileName, Len(cmdDialog.FileName) - InStr(1, cmdDialog.FileName, Chr(0))) End If cmdDialog.InitDir = strPath 'Extract the filenames from the selection strFileList = cmdDialog.FileName & Chr(0) strFiles(0) = Left(strFileList, InStr(1, strFileList, Chr(0)) - 1) strFileList = Right(strFileList, Len(strFileList) - InStr(1, strFileList, Chr(0))) Do While InStr(1, strFileList, Chr(0)) ReDim Preserve strFiles(UBound(strFiles) + 1) strFiles(UBound(strFiles)) = Left(strFileList, InStr(1, strFileList, Chr(0)) - 1) strFileList = Right(strFileList, Len(strFileList) - InStr(1, strFileList, Chr(0))) Loop 'Place the data in the resource Open gstrFileName For Binary Access Read Write Lock Write As #1 'Loop through each selected file For i = 0 To UBound(strFiles) 'Extract the bitmap data ExtractData strPath & strFiles(i) Get 1, 1, lngTemp 'If this file is empty, init the footer If lngTemp = 5 Then ReDim gudtFooter.lngFileLocation(0) ReDim gudtFooter.strFileName(0) 'Otherwise just add to the end Else ReDim Preserve gudtFooter.lngFileLocation(UBound(gudtFooter.lngFileLocation) + 1) ReDim Preserve gudtFooter.strFileName(UBound(gudtFooter.strFileName) + 1) End If 'Place the data gudtFooter.lngFileLocation(UBound(gudtFooter.lngFileLocation)) = lngTemp gudtFooter.strFileName(UBound(gudtFooter.strFileName)) = ExtractFilename(strFiles(i)) Put 1, lngTemp, gudtBMPFileHeader Put 1, , gudtBMPInfo Call RLE.Compress_RLE(gudtBMPData) Put 1, , UBound(gudtBMPData) Put 1, , gudtBMPData lngTemp = Seek(1) Put 1, , gudtFooter Put 1, 1, lngTemp Next i Close #1 'Update the display UpdateDisplay End Sub As you might see, I've changed the OpenFile stuff, It now has long file names and the XP look, if you have XP. I didn't test this on Windows version older than XP New constants Global Const HideReadOnly = &H4 'Common Dialog Constants Global Const OverWritePrompt = &H2 Global Const FileMustExist = &H1000 Global Const AllowMultiSelect = &H200 Public Const LongNames = &H200000 Public Const Explorer = &H80000 I hope you can do something with this tutorial! I've also added some extra stuff, It's all in the source. Source Marv Category:VB Category:Tutorial